Shareware Grab Bag/Shareware Grab Bag.iso/020/modula.arc/PUZZ.MOD

Text File | 1986-08-19 | 8.6 KB | 389 lines

MODULE Puzz2B;

(*  Puzz2B.Mod
    04/11/1986
    John Tal

    Version of Puzz2B.Mod  -  Generates Word search Puzzles

    Character Height & Width's are Adjustable
 *)


FROM InOut IMPORT WriteCard,OpenInput,Done,CloseInput,ReadString,ReadInt,
                  WriteInt;
FROM Terminal IMPORT WriteLn,WriteString;
FROM Printer IMPORT OpenPrinter,ClosePrinter,PrintChar,PrintString,
                    PrintTab,PrintTabMid,PrintLn;
FROM Strings IMPORT Assign,CompareStr,Length;


CONST
  vertsiz = 20;
  horzsiz = 39;

  Bound = 21845;

TYPE
  st255 = ARRAY[0..255] OF CHAR;
  st39  = ARRAY[0..39] OF CHAR;

VAR
  words : ARRAY[1..vertsiz] OF st39;
  samples : ARRAY[1..200] OF st39;
  had : ARRAY[1..200] OF INTEGER;
  d,curt,thisword,postry,xpos,ypos,direct,way,xinc,yinc,wordlen : INTEGER;
  tchar,TitleLen,copies,curx,cury,filx,fily,i,f,e,jmp,donwords : INTEGER;
  done,fits,ok2put,flips,tryingPos,figuring,filling : BOOLEAN;
  tts,title : st39;
  curchar : CHAR;
  fname1 : st39;



(* ----------------

   CardRandom Procedures originally developed by John Beidler & Paul Jackowitz
   of the University of Scranton.

*)

  Seed : ARRAY[1..2] OF CARDINAL;
  Group, Number, I : CARDINAL;

PROCEDURE RandomThree() : CARDINAL;
VAR
  Product,Carry,I : CARDINAL;
BEGIN
  LOOP
    Carry := 0;
    FOR I := 1 TO 2 DO
      Seed[I] := Seed[I] + Carry;
      Product := 3 * Seed[I];
      Carry := Product DIV Bound;
      Seed[I] := Product MOD Bound;
    END;
    CASE Carry OF
        0 : RETURN 0;
      | 1 : RETURN 1;
     ELSE
    END;
  END
END RandomThree;

PROCEDURE InitSeed( V1,V2 : CARDINAL);
BEGIN
  Seed[1] := V1 MOD Bound;
  Seed[2] := V2 MOD Bound;
END InitSeed;

PROCEDURE CardRandom (V : CARDINAL) : CARDINAL;
VAR
  Current,Answer : CARDINAL;
BEGIN
  LOOP
    Current := 1;
    Answer := 0;
    REPEAT
      IF RandomThree() = 1 THEN
        Answer := Answer + Current;
      END;
      Current := 2 * Current;
    UNTIL Current > V;
    IF Answer < V THEN
      RETURN Answer;
    END;
  END;
END CardRandom;


(* --------- *)

PROCEDURE ToSpaces(VAR dest : ARRAY OF CHAR; i : CARDINAL);
VAR
 q : CARDINAL;
BEGIN
 IF i > 0 THEN
   FOR q := 0 TO i-1 DO
     dest[q] := ' ';
   END;
   dest[i] := CHR(0);
 ELSE
   dest[0] := CHR(0);
 END;
END ToSpaces;


PROCEDURE setup;
BEGIN
WriteString('Clearing out string space.     Please stand-BY');
WriteLn;
  FOR d := 1 TO vertsiz DO
    ToSpaces(words[d],horzsiz);
  END;
  FOR d := 1 TO 200 DO
      ToSpaces(samples[d],horzsiz);
      had[d] := 0;
  END;

  WriteLn;
  WriteString('Title FOR puzzle ');
  ReadString(title);
  WriteLn;
  WriteString('Number OF Copies TO Print ');
  ReadInt(copies);
  WriteLn;
  WriteString('File TO use ');
  WriteLn;
  OpenInput(fname1);
  WriteLn;
  curt := 1;
  REPEAT
    ReadString(tts);
    WriteString(tts); WriteInt(curt,6); WriteLn;
    samples[curt] := tts;
    INC(curt);
  UNTIL (curt > 100) OR (Length(tts) = 0);
  DEC(curt);
  CloseInput;
END setup;


PROCEDURE DoThis;
VAR
  t1 : INTEGER;
BEGIN
  REPEAT
    INC(thisword);
    t1 := had[thisword];
  UNTIL t1 <> -1;
END DoThis;


PROCEDURE FigureDirect( direct : INTEGER ; VAR xinc,yinc : INTEGER);
BEGIN
  CASE direct OF
    1 :  xinc := 1;
         yinc := 0;
 |  2 :  xinc := -1;
         yinc := 0;
 |  3 :  xinc := 0;
         yinc := 1;
 |  4 :  xinc := 0;
         yinc := -1;
 |  5 :  xinc := 1;
         yinc := -1;
 |  6 :  xinc := -1;
         yinc := -1;
 |  7 :  xinc := 1;
         yinc := 1;
 |  8 :  xinc := -1;
         yinc := 1;
END;  (* CASE direct OF *)
END FigureDirect;


PROCEDURE DoesItFit() : BOOLEAN;
BEGIN
fits := TRUE;
CASE direct OF
     1 : IF xpos + wordlen-1 > horzsiz THEN
              fits := FALSE;
         END;
  |  2 : IF xpos - wordlen < 1 THEN
              fits := FALSE;
         END;
  |  3 : IF ypos + wordlen-1 > vertsiz THEN
              fits := FALSE;
         END;
  |  4 : IF ypos - wordlen < 1 THEN
              fits := FALSE;
         END;
  |  5 : IF (xpos + wordlen-1 > horzsiz) OR (ypos-wordlen < 1) THEN
              fits := FALSE;
         END;
  |  6 : IF (xpos - wordlen < 1) OR (ypos - wordlen < 1) THEN
              fits := FALSE;
         END;
  |  7 : IF (xpos + wordlen-1 > horzsiz) OR (ypos + wordlen-1 > vertsiz) THEN
              fits := FALSE;
         END;
  |  8 : IF (xpos - wordlen < 1) OR (ypos + wordlen-1 > vertsiz) THEN
              fits := FALSE;
         END;
END; (* CASE direct OF *)
RETURN fits;
END DoesItFit;


PROCEDURE IsItOk2() : BOOLEAN;
VAR
 isit : BOOLEAN;
BEGIN
  curx := xpos;
  cury := ypos;
  isit := TRUE;
  FOR tchar := 0 TO wordlen-1 DO
     curchar := samples[thisword][tchar];
     IF (words[cury][curx] <> ' ') AND
        (words[cury][curx] <> curchar) THEN
           isit := FALSE;
     END;
     curx := curx + xinc;
     cury := cury + yinc;
  END; (* FOR tchar *)
  RETURN isit;
END IsItOk2;


PROCEDURE swap(VAR a1,a2 : st39);
VAR
  temp : st39;
BEGIN
  Assign(a1,temp);  (* temp := a1 *)
  Assign(a2,a1);    (* a1 := a2;   *)
  Assign(temp,a2);  (* a2 := temp; *)
END swap;

PROCEDURE output;
BEGIN
   FOR d := 1 TO vertsiz DO
       PrintString(words[d]);
       PrintLn;
   END;

    FOR fily := 1 TO vertsiz DO
        FOR filx := 1 TO horzsiz DO
           IF words[fily][filx] = ' ' THEN
               words[fily][filx] := CHR(CardRandom(26)+65);
               (*
                  delete(words[fily],filx,1);
                  insert(CHR(TRUNC(random*25+65)),words[fily],filx);
               *)
           END;
        END;
    END;

    flips := TRUE;
    WHILE flips DO
      flips := FALSE;
         FOR i := 1 TO curt-2 DO
            IF CompareStr(samples[i],samples[i+1]) = 1 THEN
               swap(samples[i],samples[i+1]);
               flips := TRUE;
            END;
         END;
    END;
    TitleLen := 39 - (Length(title) DIV 2);

    FOR f := 1 TO copies DO
      PrintChar(CHR(12));
      PrintTab(TitleLen,title);
      PrintLn;
      PrintLn;
      FOR d := 1 TO vertsiz DO
          FOR e := 1 TO horzsiz DO
              PrintChar(words[d][e]);
              PrintChar(' ');
          END;
          PrintLn;
          PrintLn;
      END;   (* FOR d *)
      PrintLn;
      jmp := (curt-1) DIV 3;
      FOR d := 1 TO jmp DO
         PrintTab(5,samples[d]);
         PrintTab(30,samples[d+jmp]);
         PrintTab(65,samples[d+jmp*2]);
         PrintLn;
      END;
    END;  (* FOR f *)
END output;


PROCEDURE getXY;
BEGIN
  xpos := INTEGER(CardRandom(horzsiz) + 1);
          (* TRUNC(random*(horzsiz)-1)+1; *)
  ypos := INTEGER(CardRandom(vertsiz) + 1);
          (* TRUNC(random*(vertsiz)-1)+1; *)
END getXY;


PROCEDURE update;
BEGIN
  INC(direct);
  INC(way);
  IF direct = 9 THEN
    direct := 1;
  END;
  IF way = 9 THEN
     way := 1;
     figuring := FALSE;
  END;
END update;


BEGIN
  InitSeed(5AE3H,4E7FH);
  OpenPrinter;

  setup;
  thisword := 0;
  donwords := 0;
  WHILE donwords < curt-1 DO
     DoThis;   (* t1 = had[thisword] *)
     wordlen := Length(samples[thisword]);
     postry := 1;
     tryingPos := TRUE;
     WHILE tryingPos DO
       getXY;
       direct := INTEGER(CardRandom(7) + 1);
                 (* TRUNC(random*7)+1; *)
       way := 1;
       figuring := TRUE;
       WHILE figuring DO
           FigureDirect(direct,xinc,yinc);
           fits := DoesItFit();
           IF fits THEN
              ok2put := IsItOk2();
              IF ok2put THEN
                curx := xpos;
                cury := ypos;
                FOR tchar := 0 TO wordlen-1 DO
                  curchar := samples[thisword][tchar];
                     (*
                     delete(words[cury],curx,1);
                     insert(curchar,words[cury],curx);
                     *)
                   words[cury][curx] := curchar;
                   curx := curx + xinc;
                   cury := cury + yinc;
                END;
                had[thisword] := -1;
                INC(donwords);
                WriteCard(donwords,6);
                figuring := FALSE;
                tryingPos := FALSE;
              END; (* ok2put *)
           END; (* fits *)
           IF figuring THEN
            update;
           END;
       END; (* figuring *)
       IF tryingPos THEN
         postry := postry + 1;
         IF postry = 16 THEN
            tryingPos := FALSE;
         END;
       END;
     END; (* tryingPos *)
  END;   (* donwords *)

  output;

  ClosePrinter;

END Puzz2B.